;; crspmob2.lsp
;; contains code to for create-data and to implement visualizations 
;; for correspondence analysis.
;; Copyright (c) 1992-94 by Lee Bee Leng. Modified May 31, 1995 by FWY
;; Changed by FWY  Dec 97 to use new spread-plot function for improved 
;; layout, showing and closing.


(defmeth Corresp-proto :create-data
  (&key (dialog nil) 
        (row-scores t)
        (col-scores t)
        (input nil)
        (table nil)
        (expected nil))
  (if (not (eq current-object self)) (setcm self))
  (let ((Creator (send *desktop* :selected-icon))
        (Choice (list (list (if row-scores 0)
                            (if col-scores 1)
                            (if input      2)
                            (if table      3)
                            (if expected   4)))))
    (if dialog
        (setf Choice
              (choose-subset-dialog
               "Output Data Objects"
               '("Row Coordinates" "Column Coordinates"
                 "Analyzed Input Data" "Contingency Table"
                 "Expected Frequency")
               :initial (select Choice 0))))
    (when Choice
          (when (member '0 (select Choice 0))
                (send current-model :CRS-Row-Data-Object Creator))
          (when (member '1 (select Choice 0))
                (send current-model :CRS-Col-Data-Object Creator))
          (when (member '2 (select Choice 0))
                (send current-model :Create-Input-Data-Object "CRS" Creator))
          (when (member '3 (select Choice 0))
                (send current-model :CRS-Table-Data-Object Creator))
          (when (member '4 (select Choice 0))
                (send current-model :CRS-Expected-Data-Object Creator))))
  t);fwy 4.28 7/15/97 added t so gm works right
 
(defmeth Corresp-proto :CRS-Row-Data-Object (Creator)
  (data (concatenate 'string "Rows-" (send self :name))
        :created Creator
        :title (concatenate 'string "CRS Row Coordinates for "
                            (send self :title))
        :variables (mapcar #'(lambda (x) (format nil "Row-Dim~a" x))
                           (iseq (send self :MaxDim)))
        :labels (send self :labels)
        :types (repeat "Numeric" (send self :MaxDim))
        :data (combine (send self :O-Norm-Rows))))
 
(defmeth Corresp-proto :CRS-Col-Data-Object (Creator)
  (data (concatenate 'string "Cols-" (send self :name))
        :created Creator
        :title (concatenate 'string "CRS Column Coordinates for "
                            (send self :title))
        :variables (mapcar #'(lambda (x) (format nil "Col-Dim~a" x))
                           (iseq (send self :MaxDim)))
        :labels (send self :variables)
        :types (repeat "Numeric" (send self :MaxDim))
        :data (combine (send self :O-Norm-Cols))))
 
(defmeth Corresp-proto :CRS-Table-Data-Object (Creator)
  (data (concatenate 'string "Frequency-" (send self :name))
        :created Creator
        :title (concatenate 'string "Contingency Table for "
                            (send self :title))
        :variables (send self :variables)
        :labels (send self :labels)
        :types (send self :types)
        :data (combine (send self :Table))))
 
(defmeth Corresp-proto :CRS-Expected-Data-Object (Creator)
  (data (concatenate 'string "Expected-" (send self :name))
        :created Creator
        :title (concatenate 'string "Expected Frequency Table for "
                            (send self :title))
        :variables (send self :variables)
        :labels (send self :labels)
        :types (send self :types)
        :data (combine (send self :Expected))))
 
(defmeth Corresp-proto :save-model-template (data-object)
  `(Correspondence-Analysis
    :title ,(send self :title)
    :name ,(send self :name)
    :dialog nil
    :norm-opt ,(send self :norm-opt)
    :dimension ,(send self :dimension)
    :precision ,(send self :precision)
    :data (data ,(send data-object :name)
                :title ,(send data-object :title)
                :variables ',(send self :variables)
                :types     ',(send self :types)
                :labels    ',(send self :labels)
                :data      ',(send self :data))))


;-----------------
;  Visualization
;-----------------                               

(require "vista")
 
(defmeth Corresp-proto :CRS-Spin-Plot ()
  (let* (
         (NR (send self :NRows))
         (NC (send self :NCols))
         (Coordinates nil))
    (if (not (send current-model :Point-Moved-p))
        (setf Coordinates (bind-rows (send self :norm-rows)
                                     (send self :norm-cols)))
        (setf Coordinates (bind-rows (send self :o-norm-rows)
                                     (send self :o-norm-cols))))
    (setf Spinplot (spin-plot (column-list Coordinates)
                              :show nil
                             ; :size graph-size
                             ; :location11
                              :title "Spinplot"
                              :variable-labels 
                              (combine 
                               '("Dim1" "Dim2" "Dim3")
                               (repeat "" (- (send self :maxdim) 3)))
                              :depth-cuing nil))
   ; (send Spinplot :mouse-mode 'hand-rotate)
   ; (send Spinplot :use-color t)
    (send Spinplot :point-color (iseq NR) 'blue)
    (send Spinplot :point-symbol (iseq NR) 'cross)
    (send Spinplot :point-color (+ NR (iseq Nc)) 'red)
    (send Spinplot :point-symbol (+ NR (iseq Nc)) 'square)
    (send Spinplot :showing-labels t)
    (send Spinplot :point-label (iseq NR) (send self :labels))
    (send Spinplot :point-label (+ NR (iseq Nc)) (send self :variables))
    (send (first (send spinplot :slot-value 'overlays)) :remove-button ':new-x)
    (send (first (send spinplot :slot-value 'overlays)) :remove-button ':new-y)
    (send (first (send spinplot :slot-value 'overlays)) :remove-button ':new-z)
   ; (send Spinplot :plot-buttons :margin nil :new-x nil :new-y nil :box t)
   ; (send Spinplot :scale (send spinplot :scale (iseq (send spinplot :num-variables))
   ;                (* (send spinplot :scale (iseq (send spinplot :num-variables))) 2)))
   ; (send spinplot :add-box)
    (send spinplot :switch-add-box)
    (send Spinplot :linked t)

    (defmeth Spinplot :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "The Correspondence Analysis spinplot presents a spinnable 3-dimensional space containing two sets of points, one for rows of the data matrix, the other for columns. The blue crosses represent rows while the red squares represent columns.~2%"))
      (show-plot-help)
      (call-next-method :flush nil))
    spinplot))
 
 
(defmeth Corresp-proto :CRS-Scatter-Plot ()
  (let* (
         (NR (send self :NRows))
         (NC (send self :NCols))
         (axis-labels (mapcar #'(lambda (x) 
                                  (format nil "Dimension ~a" x))
                              (+ 1 (iseq (send self :maxdim)))))
         (Coordinates nil))
    (if (not (send current-model :Point-Moved-p))
        (setf Coordinates (bind-rows (send self :norm-rows)
                                     (send self :norm-cols)))
        (setf Coordinates (bind-rows (send self :o-norm-rows)
                                     (send self :o-norm-cols))))
    (setf Scatterplot (plot-points (column-list Coordinates)
                                   :show nil
                                 ;  :size graph-size
                                 ;  :location location12
                                   :title "Scatterplot"
                                   :variable-labels axis-labels))
    (send Scatterplot :mouse-mode 'brushing)
    (send Scatterplot :use-color t)
    (send Scatterplot :point-color (iseq NR) 'blue)
    (send Scatterplot :point-symbol (iseq NR) 'cross)
    (send Scatterplot :point-color (+ NR (iseq Nc)) 'red)
    (send Scatterplot :point-symbol (+ NR (iseq Nc)) 'square)
    (send Scatterplot :showing-labels t)
    (send Scatterplot :point-label (iseq NR) (send self :labels))
    (send Scatterplot :point-label (+ NR (iseq Nc)) (send self :variables))
    (send Scatterplot :plot-buttons :new-x nil :new-y nil)
    (send Scatterplot :linked t)
    (send Scatterplot :x-axis t t 2)
    (send Scatterplot :y-axis t t 2)
    (if (/= (send self :norm-opt) 2)
        (send Scatterplot :add-mouse-mode 'Move-Point
              :title "Point-Moving Mode"
              :cursor 'finger
              :click :do-point-moving))
 
    (defmeth Scatterplot :do-point-moving (x y m1 m2)
      (let* ((pt (send self :drag-point x y :draw nil))
             (var1 (first (send self :current-variables)))
             (var2 (second (send self :current-variables)))
             (n (send current-model :Nrows))
             (a nil)
             (b nil))
        (when pt
              (send current-model :Point-Moved-p t)
              (cond 
                ((or (and (= (send current-model :Norm-Opt) 0)
                          (<= pt (- n 1)))
                     (and (= (send current-model :Norm-Opt) 1)
                          (> pt (- n 1))))
                 (send self :redraw-content)
                 (setf a (send self :point-coordinate var1 pt))
                 (setf b (send self :point-coordinate var2 pt))
                 (send Scatterplot :showing-labels nil)
                 (send Spinplot :showing-labels nil)
                 (send Rows-&-Cols :unselect-all-points)
                 (send Spinplot :point-coordinate var1 pt a)
                 (send Spinplot :point-coordinate var2 pt b)
                 (send Spinplot :redraw t)
                 (send Spinplot :point-color pt 'red)
                 (send Scatterplot :point-color pt 'red)
                 (send Rows-&-Cols :point-color pt 'red)
                 (send Rows-&-Cols :point-state pt 'selected)
                 (send self :Reset-Coordinates pt a b)
                 (send self :Reset-Residuals)
                 (send self :Reset-Fitplot pt))
                (t
                 (cond 
                   ((<= pt (- n 1))
                    (send self :point-coordinate var1 pt
                          (aref (send current-model :norm-rows)
                                pt var1))
                    (send self :point-coordinate var2 pt
                          (aref (send current-model :norm-rows)
                                pt var2)))
                   (t
                    (send self :point-coordinate var1 pt
                          (aref (send current-model :norm-cols)
                                (- pt n) var1))
                    (send self :point-coordinate var2 pt
                          (aref (send current-model :norm-cols)
                                (- pt n) var2)))))))))
 
    (defmeth Scatterplot :Reset-Coordinates (pt a b)
      (let* ((n (send current-model :Nrows))
             (m (send current-model :Ncols))
             (row-mass (send current-model :row-mass))
             (col-mass (send current-model :col-mass))
             (F (send current-model :norm-rows))
             (num-rows-F (first (array-dimensions F)))
             (G (send current-model :norm-cols))
             (num-rows-G (first (array-dimensions G)))
             (vars (send self :current-variables)))
        (cond
          ((<= pt (- n 1)) #|row point moved|#
           (setf (aref F pt (first vars)) a)
           (setf (aref F pt (second vars)) b)
           (setf G (transpose (%* (inverse (%* (transpose F) F))
                                  (transpose F)
                                  (inverse (diagonal row-mass))
                                  (send current-model :table)
                                  (inverse (diagonal col-mass)))))
           (dotimes (i (send current-model :maxdim))
                    (send Scatterplot :point-coordinate 
                          i (iseq n (- (+ n m) 1))
                          (combine (select G (iseq num-rows-G) i)))
                    (send Spinplot :point-coordinate 
                          i (iseq n (- (+ n m) 1))
                          (combine (select G (iseq num-rows-G) i))))
           (when (not (send self :Hide-Cols))
                 (send self :adjust-to-data :draw nil)
                 (send self :x-axis t t 2)
                 (send self :y-axis t t 2))
           (send Spinplot :redraw t)
           (send Spinplot :adjust-to-data))
          ((> pt (- n 1)) #|column point moved|#
           (setf (aref G (- pt n) (first vars)) a)
           (setf (aref G (- pt n) (second vars)) b)
           (setf F (%* (inverse (diagonal row-mass))
                       (send current-model :table)
                       (inverse (diagonal col-mass))
                       G
                       (inverse (%* (transpose G) G))))
           (dotimes (i (send current-model :maxdim))
                    (send Scatterplot :point-coordinate 
                          i (iseq n)
                          (combine (select F (iseq num-rows-F) i)))
                    (send Spinplot :point-coordinate 
                          i (iseq n)
                          (combine (select F (iseq num-rows-F) i))))
           (when (not (send self :Hide-Rows))
                 (send self :adjust-to-data :draw nil)
                 (send self :x-axis t t 2)
                 (send self :y-axis t t 2))
           (send Spinplot :redraw t)
           (send Spinplot :adjust-to-data)))
        (send current-model :norm-rows F)
        (send current-model :norm-cols G)))
 
    (defmeth Scatterplot :Reset-Residuals ()
      (let* ((n (send current-model :Nrows))
             (m (send current-model :Ncols))
             (row-mass (send current-model :row-mass))
             (col-mass (send current-model :col-mass))
             (F (send current-model :norm-rows))
             (G (send current-model :norm-cols))
             (dims (send dimension-list :selection))
             (fitted nil)
             (residual nil)
             (n-pts (send residual-plot :num-points))
             (pt-st (send residual-plot :point-state (iseq n-pts))))
        (setf fitted (%* (diagonal row-mass) 
                         (select F (iseq n) dims)
                         (transpose (select G (iseq m) dims))
                         (diagonal col-mass)))
        (setf residual (- (send current-model :Deviation) Fitted))
        (send current-model :Residuals residual)
        (send Residual-plot :clear-points :draw nil)
        (send Residual-plot :add-points
              (combine (row-list (send current-model :deviation)))
              (combine (row-list (send current-model :residuals))) :draw nil)
        (send Residual-plot :adjust-to-data)
        (send Residual-plot :x-axis t t 2)
        (send Residual-plot :y-axis t t 2)
        (send residual-plot :point-state (iseq n-pts) pt-st)
        (send Residual-plot :abline 0 0)))
 
    (defmeth Scatterplot :Reset-Fitplot (pt)
      (let ((A (first (send current-model :gsvd)))
            (B (third (send current-model :gsvd)))
            (frame (send fit-plot :content-rect))
            (num-ticks (third (send fit-plot :x-axis)))
            (Du nil)
            (Inertia nil))
        (cond
          ((= (send current-model :norm-opt) 0)
           (setf Du (%* (inverse (%* (transpose A) A))
                       (transpose A)
                       (diagonal (send current-model :Row-Mass))
                       (send current-model :Norm-Rows))))
          ((= (send current-model :norm-opt) 1)
           (setf Du (%* (inverse (%* (transpose B) B))
                       (transpose B)
                       (diagonal (send current-model :Col-Mass))
                       (send current-model :Norm-Cols)))))
        (setf Inertia (^ (diagonal Du) 2))
        (send fit-plot :start-buffering)
        (send fit-plot :clear-lines)
        (send fit-plot :add-lines 
              (iseq 1 (send current-model :maxdim))
              (^ (second (send current-model :gsvd)) 2))
        (send fit-plot :add-lines
              (iseq 1 (send current-model :maxdim)) Inertia
              :type 'dashed)
        (send fit-plot :adjust-to-data :draw nil)
        (send fit-plot :range 0 1 (send current-model :maxdim))
        (send fit-plot :x-axis t t num-ticks)
        (send fit-plot :y-axis t t 2)
        (send fit-plot :buffer-to-screen)))
 
 
    (setf HideRow-item (send menu-item-proto :new "Hide Row Points"
                        :action
                        #'(lambda ()
                            (send Scatterplot :Show-or-Hide-Row-Pts))))
 
    (send Scatterplot :add-slot 'Hide-Rows)
    (defmeth Scatterplot :Hide-Rows (&optional (show t set))
      (if set (setf (slot-value 'Hide-Rows) show))
      (slot-value 'Hide-Rows))
 
    (defmeth Scatterplot :Show-or-Hide-Row-Pts ()
      (let* ((n (send current-model :Nrows)))
        (send Scatterplot :Hide-Rows
              (not (send Scatterplot :Hide-Rows)))
        (cond
          ((send self :Hide-Rows)
           (send self :point-state (iseq n) 'invisible)
           (send HideRow-Item :title "Show Row Points")
           (send Spinplot :point-masked (iseq n) (repeat t n))
           (send Spinplot :adjust-to-data)
           (send Rows-&-Cols :point-masked (iseq n) (repeat t n))
           (send Rows-&-Cols :redraw))
          (t
           (send self :point-state (iseq n) 'normal)
           (send HideRow-Item :title "Hide Row Points")
           (send Spinplot :point-masked (iseq n) (repeat nil n))
           (send Spinplot :adjust-to-data)
           (send Rows-&-Cols :point-masked (iseq n) (repeat nil n))
           (send Rows-&-Cols :redraw)
           ))
        (send self :adjust-to-data :draw nil)
        (send self :x-axis t t 2)
        (send self :y-axis t t 2)))
    
    (setf HideCol-item (send menu-item-proto :new "Hide Column Points"
                        :action
                        #'(lambda ()
                            (send Scatterplot :Show-or-Hide-Col-Pts))))
 
    (send Scatterplot :add-slot 'Hide-Cols)
    (defmeth Scatterplot :Hide-Cols (&optional (show t set))
      (if set (setf (slot-value 'Hide-Cols) show))
      (slot-value 'Hide-Cols))
 
    (defmeth Scatterplot :Show-or-Hide-Col-Pts ()
      (let* ((n (send current-model :Nrows))
             (m (send current-model :Ncols)))
        (send Scatterplot :Hide-Cols
              (not (send Scatterplot :Hide-Cols)))
        (cond
          ((send self :Hide-Cols)
           (send self :point-state (iseq n (- (+ n m) 1)) 'invisible)
           (send HideCol-Item :title "Show Column Points")
           (send Spinplot :point-masked (iseq n (- (+ n m) 1))
                                        (repeat t m))
           (send Spinplot :adjust-to-data)
           (send Rows-&-Cols :point-masked (iseq n (- (+ n m) 1))
                                           (repeat t m))
           (send Rows-&-Cols :redraw))
          (t
           (send self :point-state (iseq n (- (+ n m) 1)) 'normal)
           (send HideCol-Item :title "Hide Column Points")
           (send Spinplot :point-masked (iseq n (- (+ n m) 1))
                                        (repeat nil m))
           (send Spinplot :adjust-to-data)
           (send Rows-&-Cols :point-masked (iseq n (- (+ n m) 1))
                                           (repeat nil m))
           (send Rows-&-Cols :redraw)))
        (send self :adjust-to-data :draw nil)
        (send self :x-axis t t 2)
        (send self :y-axis t t 2)))
 
    (send Scatterplot :new-menu "Scatterplot"
          :items '(mouse resize-brush dash
                   symbol color selection dash))
    (send (send Scatterplot :menu)
          :append-items HideRow-Item HideCol-Item)

    (defmeth Scatterplot :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil "The Correspondence Analysis scatterplot presents a 2-dimensional space containing two sets of points, one for rows of the data matrix, the other for columns. The blue crosses represent rows while the red squares represent columns.~2%"))
      (show-plot-help)
      )

    Scatterplot))
 
 
(defmeth Corresp-proto :CRS-Name-List ()
  (setf Rows-&-Cols (name-list (combine (send self :labels)
                                          (send self :variables))
                               :show nil
                             ;  :location location13
                               :title "Rows and Columns"))
  (send Rows-&-Cols :use-color t)
  (send Rows-&-Cols :point-color (iseq (send self :NRows)) 'blue)
  (send Rows-&-Cols :point-color 
        (+ (send self :NRows) (iseq (send self :NCols))) 'red)
  (send Rows-&-Cols :linked t)
  (send Rows-&-Cols :new-menu "RowCol" 
          :items '(ERASE-SELECTION FOCUS-ON-SELECTION SHOW-ALL
                                   COLOR SELECTION))
  (send Rows-&-Cols :fix-name-list)
 ; (send Rows-&-Cols :has-h-scroll (max (screen-size)))
 ; (send Rows-&-Cols :has-v-scroll (max (screen-size)))
  (defmeth Rows-&-Cols :do-select-click (x y m1 m2)
    (call-next-method x y m1 m2)
    (let* ((nr (send current-model :NRows))
           (nc (send current-model :NCols))
           (np (send self :num-points))
           (s  (send self :selection)))
      (if (= (length s) 2)
          (when (or (and (< (first s) nr) (>= (second s) nr))
                    (and (>= (first s) nr) (< (second s) nr)))
                (send Residual-plot :selection 
                      (list (identify-residual s nr nc)))
                (send Residual-plot :point-color 
                      (send Residual-plot :selection) 'black)
                (send Residual-plot :redraw t))
          (send Residual-plot :unselect-all-points))))
;  #-msdos(send Rows-&-Cols :size (- (select namelist-size 0) msdos-fiddle)
;               (- (select namelist-size 1) msdos-fiddle))
;  #+msdos(send Rows-&-Cols :size (- (select namelist-size 0) msdos-fiddle)
;               (- (select namelist-size 1) msdos-fiddle))

  (defmeth rows-&-cols :plot-help ()
    (plot-help-window (strcat "Help for " (send self :title)))
    (paste-plot-help (format nil "The ROWS and COLUMNS window presents a list of the names of the rows and columns of the data matrix. The blue names are for rows while the red names are for columns. This window is linked to other windows. By clicking on a name you will see the corresponding point highighted and labeled in other windows. You can also drag your cursor over several names, or shift-click on several names to select and highlight several row and/or column names.~2%"))
    (show-plot-help))

    rows-&-cols)
 
  
(defmeth Corresp-proto :CRS-Residual-Plot ()
  (let (
        (resid nil))
    (if (not (send current-model :Point-Moved-p))
        (setf resid (send self :residuals))
        (setf resid (send self :o-residuals)))
    (setf Residual-Plot (plot-points
                         (/ (combine (row-list (send self :deviation)))
                            (combine (row-list (send self :expected))))
                         (combine (row-list resid))
                         :show nil
                        ; :size graph-size
                        ; :location location21
                         :title "Residual Plot"
                         :variable-labels (list "(ObsF - ExpF)/ExpF" 
                                                "Standardized Residuals")))
    (send Residual-plot :abline 0 0)
    (send Residual-plot :use-color t)
    (send Residual-plot :mouse-mode 'brushing)
    (send Residual-plot :brush 0 0 10 10)
    (send Residual-plot :point-color 
          (iseq (send Residual-plot :num-points)) 'green)
    (send Residual-plot :point-symbol 
          (iseq (send Residual-plot :num-points)) 'square)
    (send Residual-plot :x-axis t t 5)
    (send Residual-plot :y-axis t t 3)
    (send Residual-plot :plot-buttons :new-x nil :new-y nil)
;(break)
    (let* ((nr (send self :nrows))
           (nc (send self :ncols)))
      (defmeth Residual-plot :do-brush-motion (x y)
        (when (not (or (send Scatterplot :Hide-Rows)
                       (send Scatterplot :Hide-Cols)))
              (call-next-method x y)
              (when (equal 'brushing (send self :mouse-mode))
                    (when (send self :points-hilited)
                          (send spinplot :selection
                                (locate-residual 
                                 (first (send self :points-hilited)) nr nc))
                          (send self :points-hilited 
                                (list (first (send self :points-hilited)))))
                    (if (not (send self :points-hilited))
                        (send scatterplot :show-all-points)))
              ))
      (defmeth Residual-plot :do-select-click (x y m1 m2)
        (when (not (or (send Scatterplot :Hide-Rows)
                       (send Scatterplot :Hide-Cols)))
              (call-next-method x y m1 m2)
              (when (send self :selection)
                    (send spinplot :selection
                          (locate-residual 
                           (first (send self :selection)) nr nc))
                    (send self :selection 
                          (list (first (send self :selection)))))
              (if (not (send self :selection))
                  (send scatterplot :show-all-points)))))
    (send Residual-Plot :new-menu "Residual-Plot" 
          :items '(ERASE-SELECTION FOCUS-ON-SELECTION SHOW-ALL 
                   SYMBOL COLOR SELECTION DASH RESCALE OPTIONS))
    (defmeth Residual-plot :plot-help ()
      (plot-help-window (strcat "Help for " (send self :title)))
      (paste-plot-help (format nil 
"The residuals plot is a plot of the residuals versus the difference between the Observed and Expected frequencies in the data matrix.~2%"))
      (paste-plot-help (format nil
"The points are green, rather than blue or red, because each point is for a cell of the data matrix, not for a row or column. Note that when you select a  residual point, the row and column that it appears in are highlighted and labled in the other windows. Only one point may be selected at a time.~2%"))
      (show-plot-help))
    Residual-plot))

;;                       -- End of Part II -- 